home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / faq-s.zip / ABOUT.PAS next >
Pascal/Delphi Source File  |  1991-04-13  |  8KB  |  297 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit about;
  5.  
  6. interface
  7.  
  8. uses gentypes,configrt,gensubs,subs1,subs2,modem;
  9.  
  10. procedure aboutthisbbs;
  11.  
  12. implementation
  13.  
  14. procedure aboutthisbbs;
  15. var ab:abrec;
  16.  
  17.   function numabouts:integer;
  18.   begin
  19.     numabouts:=filesize(abfile)
  20.   end;
  21.  
  22.   procedure seekabfile (n:integer);
  23.   begin
  24.     seek (abfile,n-1)
  25.   end;
  26.  
  27.   procedure openabfile;
  28.   var n:integer;
  29.   begin
  30.     n:=ioresult;
  31.     assign (abfile,bbsdatadir+'Aboutbbs.dat');
  32.     reset (abfile);
  33.     if ioresult<>0 then begin
  34.       close (abfile);
  35.       n:=ioresult;
  36.       rewrite (abfile)
  37.     end
  38.   end;
  39.  
  40.   procedure listabouts;
  41.   var cnt:integer;
  42.       b:boolean;
  43.   begin
  44.     b:=true;
  45.     seekabfile (1);
  46.     for cnt:=1 to numabouts do begin
  47.       read (abfile,ab);
  48.       if (ulvl>=ab.level) or issysop then begin
  49.         if b then begin
  50.           writeln;
  51.           writehdr ('Information Files');
  52.           writestr (^R'[Num] [Title]'^M);
  53.           b:=false
  54.         end;
  55.         write (^R'['^S);
  56.         tab (strr(cnt),3);
  57.         write (^R'] ['^S);
  58.         tab (ab.title,60);
  59.         writeln (^R']');
  60.         if break then exit
  61.       end
  62.     end;
  63.     if b then writestr ('Sorry, no information files are available!')
  64.   end;
  65.  
  66.   function getaboutnum:integer;
  67.   var n:integer;
  68.   begin
  69.     getaboutnum:=0;
  70.     repeat
  71.       writestr ('Information File Number [?/List]:');
  72.       if length(input)=0 then exit;
  73.       if upcase(input[1])='?'
  74.         then listabouts
  75.         else begin
  76.           n:=valu(input);
  77.           if (n<1) or (n>numabouts) then begin
  78.             writestr (^M'Sorry, file number out of range!');
  79.             exit
  80.           end;
  81.           seekabfile (n);
  82.           read (abfile,ab);
  83.           if (ulvl<ab.level) and (not issysop) then begin
  84.             reqlevel (ab.level);
  85.             exit
  86.           end;
  87.           getaboutnum:=n;
  88.           exit
  89.         end
  90.     until hungupon
  91.   end;
  92.  
  93.   procedure showaboutfile (n:integer);
  94.   begin
  95.     seekabfile (n);
  96.     read (abfile,ab);
  97.     if ulvl<ab.level then begin
  98.       reqlevel (ab.level);
  99.       exit
  100.     end;
  101.     writeln (^M'Title:   '^S,ab.title,
  102.              ^M'Updated: '^S,timestr(ab.when),' at ',datestr(ab.when),^M);
  103.     printfile (ab.fname)
  104.   end;
  105.  
  106.   procedure makeaboutfile;
  107.   var t:text;
  108.       b:boolean;
  109.   begin
  110.     assign (t,ab.fname);
  111.     rewrite (t);
  112.     writestr (^M'Enter text, /S to save:'^M);
  113.     repeat
  114.       lastprompt:='Continue.'^M;
  115.       wordwrap:=true;
  116.       getstr (1);
  117.       b:=match(input,'/S');
  118.       if not b then writeln (t,input)
  119.     until b;
  120.     textclose (t);
  121.     writestr (^M'File created!');
  122.     ab.when:=now;
  123.     writelog (3,2,ab.fname)
  124.   end;
  125.  
  126.   procedure addabout;
  127.   begin
  128.     writestr ('Title:');
  129.     if length(input)=0 then exit;
  130.     ab.title:=input;
  131.     writestr ('Level:');
  132.     ab.level:=valu(input);
  133.     writestr ('Path & Filename ['+textfiledir+']:');
  134.     if length(input)=0 then exit;
  135.     if pos('\',input)=0 then input:=textfiledir+input;
  136.     ab.fname:=input;
  137.     if not exist(ab.fname) then begin
  138.       writestr ('File not found!  Enter file now? *');
  139.       if yes then makeaboutfile
  140.     end;
  141.     ab.when:=now;
  142.     seekabfile (numabouts+1);
  143.     write (abfile,ab);
  144.     writestr ('File added.');
  145.     writelog (3,1,ab.title)
  146.   end;
  147.  
  148.   procedure changeabout;
  149.   var n:integer;
  150.  
  151.     procedure getstr (prompt:mstr; var ss; len:integer);
  152.     var a:anystr absolute ss;
  153.     begin
  154.       writeln (^B^M'  Current ',prompt,' is: '^S,a);
  155.       buflen:=len;
  156.       writestr ('Enter new '+prompt+':');
  157.       if length(input)>0 then a:=input;
  158.     end;
  159.  
  160.     procedure getint (prompt:mstr; var i:integer);
  161.     var q:sstr;
  162.         n:integer;
  163.     begin
  164.       str (i,q);
  165.       getstr (prompt,q,5);
  166.       n:=valu (q);
  167.       if n<>0 then i:=n
  168.     end;
  169.  
  170.   begin
  171.     n:=getaboutnum;
  172.     if n=0 then exit;
  173.     seekabfile (n);
  174.     read (abfile,ab);
  175.     getstr ('title',ab.title,80);
  176.     getint ('level',ab.level);
  177.     getstr ('filename',ab.fname,80);
  178.     if not exist (ab.fname) then write (^B^M,ab.fname,' not found!');
  179.     writestr (^M'Create new file '+ab.fname+'? *');
  180.     if yes then makeaboutfile;
  181.     seekabfile (n);
  182.     write (abfile,ab);
  183.     writelog (3,3,ab.title);
  184.   end;
  185.  
  186.   procedure deleteabout;
  187.   var cnt,n:integer;
  188.       f:file;
  189.   begin
  190.     n:=getaboutnum;
  191.     if n=0 then exit;
  192.     seekabfile (n);
  193.     read (abfile,ab);
  194.     writestr ('Delete ['^S+ab.title+^P']? *');
  195.     if not yes then exit;
  196.     writestr ('Erase disk file '+ab.fname+'? *');
  197.     if yes then begin
  198.       assign (f,ab.fname);
  199.       erase (f);
  200.       if ioresult<>0
  201.         then writestr ('Couldn''t erase file.')
  202.     end;
  203.     for cnt:=n+1 to numabouts do begin
  204.       seekabfile (cnt);
  205.       read (abfile,ab);
  206.       seekabfile (cnt-1);
  207.       write (abfile,ab)
  208.     end;
  209.     seekabfile (numabouts);
  210.     truncate (abfile);
  211.     writestr (^M'Deleted.');
  212.     writelog (3,4,ab.title)
  213.   end;
  214.  
  215.   procedure updateabout;
  216.   var n:integer;
  217.   begin
  218.     n:=getaboutnum;
  219.     if n=0 then exit;
  220.     seekabfile (n);
  221.     read (abfile,ab);
  222.     ab.when:=now;
  223.     seekabfile (n);
  224.     write (abfile,ab);
  225.     writeln ('File ',n,' time/date updated.');
  226.     writelog (3,5,ab.title)
  227.   end;
  228.  
  229.   procedure sysopcommands;
  230.   var q:integer;
  231.   begin
  232.     if not issysop then begin
  233.       reqlevel (sysoplevel);
  234.       exit
  235.     end;
  236.     repeat
  237.       q:=menu ('Info File Sysop','ABOUT','QACDU?');
  238.       case q of
  239.         2:addabout;
  240.         3:changeabout;
  241.         4:deleteabout;
  242.         5:updateabout;
  243.         6:begin
  244. writeln ('C╔═════════════════════════════════════╗Hs');
  245. writeln ('uC║ About (Info) Sysop Section          ║Hs');
  246. writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
  247. writeln ('u═════════════════════════════════╗HC║ [A]  s');
  248. writeln ('uAdd About File (Info File)     ║HC║ [Cs');
  249. writeln ('u]  Change About File              ║HC║ [s');
  250. writeln ('uD]  Delete About File              ║Hs');
  251. writeln ('uC║ [Q]  Quit                           s');
  252. writeln ('u║HC║ [U]  Update About File       s');
  253. writeln ('u       ║HC║ [?]  View This Menu   s');
  254. writeln ('u              ║HC╚═══════════════════════════════A');
  255. writeln ('C══════╝');
  256. writeln;
  257. pause;
  258.            end;
  259.       end
  260.     until hungupon or (q=1)
  261.   end;
  262.  
  263. label exit;
  264. var prompt:lstr;
  265.     n:integer;
  266.     k:char;
  267. begin
  268.   openabfile;
  269.   listabouts;
  270.   writehdr ('Information Files');
  271.   repeat
  272.     prompt:=^M'Information File Number [?/List]-[Q/Quit]';
  273.     if issysop then prompt:=prompt+'-[%/Sysop]';
  274.     prompt:=prompt+':';
  275.     writestr (prompt);
  276.     if (length(input)=0) or (upcase(input[1])='Q') then goto exit;
  277.     k:=upcase(input[1]);
  278.     case k of
  279.       'Q':goto exit;
  280.       '%':sysopcommands;
  281.       '?':listabouts;
  282.       else begin
  283.         n:=valu(input);
  284.         if n<>0 then
  285.           if (n<0) or (n>numabouts)
  286.             then writestr ('Out of range!')
  287.             else showaboutfile (n)
  288.       end
  289.     end
  290.   until hungupon;
  291.   exit:
  292.   close (abfile)
  293. end;
  294.  
  295. begin
  296. end.
  297.